home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / rbtree.scm < prev    next >
Encoding:
Text File  |  1994-05-29  |  13.9 KB  |  364 lines
  1. ;;;;"rbtree.scm" Red-black trees    -*-Scheme-*-
  2. ;;;; Copyright (C) 1990 Patrick G. Solbavarro.
  3. ;;;; Copyright (C) 1993 Aubrey Jaffer
  4.  
  5. ;;;; Red-black trees as in "Introduction to Algorithms," by Cormen, Leiserson,
  6. ;;;; and Rivest, chapter 15.
  7.  
  8. ;;;; PGS, 6 Jul 1990
  9. ;;; jaffer@ai.mit.edu Ported to SLIB, 1/6/93
  10.  
  11. (require 'record)
  12. (define rb-tree
  13.   (make-record-type
  14.    "rb-tree"
  15.    '(root left-rotation-field-maintainer right-rotation-field-maintainer
  16.       insertion-field-maintainer deletion-field-maintainer
  17.       prior?)))
  18.  
  19. (define make-rb-tree
  20.   (let ((mrb (record-constructor rb-tree)))
  21.     (lambda (left-rotation-field-maintainer
  22.          right-rotation-field-maintainer
  23.          insertion-field-maintainer
  24.          deletion-field-maintainer
  25.          prior?)
  26.       (mrb #f left-rotation-field-maintainer right-rotation-field-maintainer
  27.        insertion-field-maintainer deletion-field-maintainer
  28.        prior?))))
  29.  
  30. (define rb-tree-root (record-accessor rb-tree 'root))
  31. (define set-rb-tree-root! (record-modifier rb-tree 'root))
  32. (define rb-tree-left-rotation-field-maintainer
  33.   (record-accessor rb-tree 'left-rotation-field-maintainer))
  34. (define rb-tree-right-rotation-field-maintainer
  35.   (record-accessor rb-tree 'right-rotation-field-maintainer))
  36. (define rb-tree-insertion-field-maintainer
  37.   (record-accessor rb-tree 'insertion-field-maintainer))
  38. (define rb-tree-deletion-field-maintainer
  39.   (record-accessor rb-tree 'deletion-field-maintainer))
  40. (define rb-tree-prior? (record-accessor rb-tree 'prior?))
  41.  
  42. (define rb-node (make-record-type "rb-node" '(left right parent color data)))
  43. (define make-rb-node
  44.   (let ((mrn (record-constructor rb-node)))
  45.     (lambda (data)
  46.       (mrn #f #f #f 'black data))))
  47.  
  48. (define rb-node-left (record-accessor rb-node 'left))
  49. (define set-rb-node-left! (record-modifier rb-node 'left))
  50. (define rb-node-right (record-accessor rb-node 'right))
  51. (define set-rb-node-right! (record-modifier rb-node 'right))
  52. (define rb-node-parent (record-accessor rb-node 'parent))
  53. (define set-rb-node-parent! (record-modifier rb-node 'parent))
  54. (define rb-node-color (record-accessor rb-node 'color))
  55. (define set-rb-node-color! (record-modifier rb-node 'color))
  56. (define rb-node-data (record-accessor rb-node 'data))
  57. (define set-rb-node-data! (record-modifier rb-node 'data))
  58.  
  59. ;;;; Rotations
  60. (define (rb-left-rotate tree x)
  61.   (let ((y (rb-node-right x)))
  62.     (let ((beta (rb-node-left y)))
  63.       (set-rb-node-right! x beta)
  64.       ;; make sure x's new child knows who its parent is
  65.       (if beta (set-rb-node-parent! beta x)))
  66.     ;; y is now x's parent's child
  67.     (let ((subtree-parent (rb-node-parent x)))
  68.       (set-rb-node-parent! y subtree-parent)
  69.       ;; if x was tree root, y is now
  70.       (if (not subtree-parent)
  71.       (set-rb-tree-root! tree y)
  72.       ;; otherwise if x wasn't tree root, have to figure out which child
  73.       ;; it was, so we can update parent's corresponding child field.
  74.       (if (eq? x (rb-node-left subtree-parent))
  75.           (set-rb-node-left! subtree-parent y)
  76.           (set-rb-node-right! subtree-parent y))))
  77.     ;; now x is y's left child
  78.     (set-rb-node-left! y x)
  79.     ;; and y is x's parent
  80.     (set-rb-node-parent! x y)
  81.     ;; invoke augmented field maintenance routine if there is one
  82.     (let ((augmented-field-maintenance-routine
  83.        (rb-tree-left-rotation-field-maintainer tree)))
  84.       (if augmented-field-maintenance-routine
  85.       (augmented-field-maintenance-routine x y)))))
  86.  
  87. (define (rb-right-rotate tree y)
  88.   (let ((x (rb-node-left y)))
  89.     (let ((beta (rb-node-right x)))
  90.       (set-rb-node-left! y beta)
  91.       ;; make sure y's new child knows who its parent is
  92.       (if beta (set-rb-node-parent! beta y)))
  93.     ;; x is now y's parent's child
  94.     (let ((subtree-parent (rb-node-parent y)))
  95.       (set-rb-node-parent! x subtree-parent)
  96.       ;; if y was tree root, x is now
  97.       (if (not subtree-parent)
  98.       (set-rb-tree-root! tree x)
  99.       ;; otherwise if y wasn't tree root, have to figure out which child
  100.       ;; it was, so we can update parent's corresponding child field.
  101.       (if (eq? y (rb-node-right subtree-parent))
  102.           (set-rb-node-right! subtree-parent x)
  103.           (set-rb-node-left! subtree-parent x))))
  104.     ;; now y is x's right child
  105.     (set-rb-node-right! x y)
  106.     ;; and x is y's parent
  107.     (set-rb-node-parent! y x)
  108.     ;; invoke augmented field maintenance routine if there is one
  109.     (let ((augmented-field-maintenance-routine
  110.        (rb-tree-right-rotation-field-maintainer tree)))
  111.       (if augmented-field-maintenance-routine
  112.       (augmented-field-maintenance-routine x y)))))
  113.  
  114.  
  115. ;;;; Insertion.
  116.  
  117. (define (rb-insert! tree x)
  118.   ;; normal binary tree insertion
  119.   (define (rb-binary-tree-insert tree z)
  120.     (let ((prior? (rb-tree-prior? tree))
  121.       (y #f)
  122.       (z-data (rb-node-data z)))
  123.       (do ((x (rb-tree-root tree)))
  124.       ((not x))
  125.     (set! y x)
  126.     (if (prior? z-data (rb-node-data x))
  127.         ;; descend left
  128.         (set! x (rb-node-left x))
  129.         ;; descend right
  130.         (set! x (rb-node-right x))))
  131.       ;; link z in under y
  132.       (set-rb-node-parent! z y)
  133.       ;; if y was null, z is now the root of the tree
  134.       (if (not y)
  135.       (set-rb-tree-root! tree z)
  136.       ;; but otherwise have to make z appropriate child of y
  137.       (if (prior? z-data (rb-node-data y))
  138.           (set-rb-node-left! y z)
  139.           (set-rb-node-right! y z)))))
  140.   ;; start by doing normal binary tree insertion
  141.   (rb-binary-tree-insert tree x)
  142.   (let ((augmented-field-maintenance-routine
  143.      (rb-tree-insertion-field-maintainer tree)))
  144.     (if augmented-field-maintenance-routine
  145.     (augmented-field-maintenance-routine x)))
  146.   (set-rb-node-color! x 'red)
  147.   (do ((y 'uninitialized))
  148.       ((or (eq? x (rb-tree-root tree))
  149.        (not (eq? (rb-node-color (rb-node-parent x)) 'red))))
  150.     ;; if x's parent is a left child of its grandparent
  151.     (if (eq? (rb-node-parent x)
  152.          (rb-node-left (rb-node-parent (rb-node-parent x))))
  153.     (begin
  154.       ;; get other child of x's grandparent
  155.       (set! y (rb-node-right (rb-node-parent (rb-node-parent x))))
  156.       ;; if uncle was red
  157.       (if (and y (eq? (rb-node-color y) 'red))
  158.           ;; making grandparent red, maintain lower invariants
  159.           (begin
  160.         (set-rb-node-color! (rb-node-parent x) 'black)
  161.         (set-rb-node-color! y 'black)
  162.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  163.         (set! x (rb-node-parent (rb-node-parent x))))
  164.           ;; if uncle was black,
  165.           (begin
  166.         ;; if x is a right child,
  167.         (cond ((eq? x (rb-node-right (rb-node-parent x)))
  168.                ;; left-rotate about parent
  169.                (set! x (rb-node-parent x))
  170.                (rb-left-rotate tree x)))
  171.         (set-rb-node-color! (rb-node-parent x) 'black)
  172.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  173.         (rb-right-rotate tree (rb-node-parent (rb-node-parent x))))))
  174.     ;; if x's parent is a right child of its grandparent
  175.     (begin
  176.       ;; get other child of x's grandparent
  177.       (set! y (rb-node-left (rb-node-parent (rb-node-parent x))))
  178.       ;; if uncle was red
  179.       (if (and y (eq? (rb-node-color y) 'red))
  180.           ;; making grandparent red, maintain lower invariants
  181.           (begin
  182.         (set-rb-node-color! (rb-node-parent x) 'black)
  183.         (set-rb-node-color! y 'black)
  184.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  185.         (set! x (rb-node-parent (rb-node-parent x))))
  186.           (begin
  187.         ;; if x is a left child,
  188.         (cond ((eq? x (rb-node-left (rb-node-parent x)))
  189.                ;; right-rotate about parent
  190.                (set! x (rb-node-parent x))
  191.                (rb-right-rotate tree x)))
  192.         (set-rb-node-color! (rb-node-parent x) 'black)
  193.         (set-rb-node-color! (rb-node-parent (rb-node-parent x)) 'red)
  194.         (rb-left-rotate tree (rb-node-parent (rb-node-parent x))))))))
  195.   (set-rb-node-color! (rb-tree-root tree) 'black))
  196.  
  197. ;;;; Queries
  198. (define (rb-node-minimum node)
  199.   (let ((node-left (rb-node-left node)))
  200.     (if node-left
  201.     (rb-node-minimum node-left)
  202.     node)))
  203.  
  204. (define (rb-node-maximum node)
  205.   (let ((node-right (rb-node-right node)))
  206.     (if node-right
  207.     (rb-node-maximum node-right)
  208.     node)))
  209.  
  210.  
  211. (define (rb-tree-minimum tree)
  212.   (rb-node-minimum (rb-tree-root tree)))
  213.  
  214. (define (rb-tree-maximum tree)
  215.   (rb-node-maximum (rb-tree-root tree)))
  216.  
  217. (define (rb-node-successor x)
  218.   (let ((node-right (rb-node-right x)))
  219.     (if node-right (rb-node-minimum node-right)
  220.     (do ((y (rb-node-parent x)))
  221.         ((or (not y) (not (eq? x (rb-node-right y))))
  222.          y)
  223.       (set! x y)
  224.       (set! y (rb-node-parent y))))))
  225.  
  226. (define (rb-node-predecessor x)
  227.   (if (rb-node-left x) (rb-node-minimum (rb-node-left x))
  228.       (do ((y (rb-node-parent x)))
  229.       ((or (not y) (not (eq? x (rb-node-left y))))
  230.        y)
  231.     (set! x y)
  232.     (set! y (rb-node-parent y)))))
  233.  
  234.  
  235. ;;;; Deletion.  We do not entirely follow Cormen, Leiserson and Rivest's lead
  236. ;;;; here, because their use of sentinels is in rather obscenely poor taste.
  237. ;;;; Instead, we pass X's parent to RB-DELETE-FIXUP and check explicitly for
  238. ;;;; the null case.
  239.  
  240. ;;; The node that is actually deleted may not be the one passed in, so if a
  241. ;;; resource is being maintained, what should be put back on the freelist is
  242. ;;; the node returned by this procedure.
  243. (define (rb-delete! tree z)
  244.   ;; first part is usual binary tree deletion
  245.   (let* ((y 'uninitialized)
  246.      (x 'uninitialized))
  247.     (if (or (not (rb-node-left z)) (not (rb-node-right z)))
  248.     ;; if node to delete has only one child or none, can just splice it
  249.     ;; out
  250.     (set! y z)
  251.     ;; if node to delete has two children, find its successor (which has
  252.     ;; only one child) and splice successor in in place of deleted node
  253.     (set! y (rb-node-successor z)))
  254.     ;; know at this point that y has at most one child; get it in x
  255.     (if (rb-node-left y)
  256.     (set! x (rb-node-left y))
  257.     (set! x (rb-node-right y)))
  258.     ;; we'll want this later
  259.     (let ((y-parent (rb-node-parent y)))
  260.       ;; this child takes y's place.
  261.       (if x (set-rb-node-parent! x (rb-node-parent y)))
  262.       ;; if y was the root, have to update the tree
  263.       (if (not y-parent)
  264.       (set-rb-tree-root! tree x)
  265.       ;; if y wasn't root, have to tell y's parent about new child x
  266.       (if (eq? y (rb-node-left y-parent))
  267.           (set-rb-node-left! y-parent x)
  268.           (set-rb-node-right! y-parent x)))
  269.       (let ((deletion-field-maintenance-routine
  270.          (rb-tree-deletion-field-maintainer tree))
  271.         (insertion-field-maintenance-routine
  272.          (rb-tree-insertion-field-maintainer tree)))
  273.     ;; if we have a deletion field maintainer, use it to make tree
  274.     ;; consistent with y's removal.
  275.     (if deletion-field-maintenance-routine
  276.         (deletion-field-maintenance-routine y))
  277.     ;; if y was actually z's successor, we aren't really deleting y but z,
  278.     ;; and inserting y in z's place.  So update z's data field to y's.
  279.     (cond ((not (eq? y z))
  280.            (cond (deletion-field-maintenance-routine
  281.               (deletion-field-maintenance-routine z) ;deleting z
  282.               (insertion-field-maintenance-routine y))) ;inserting y
  283.            (set-rb-node-data! z (rb-node-data y)))))
  284.       ;; clean up tree if we've unbalanced it
  285.       (if (eq? (rb-node-color y) 'black)
  286.       (rb-delete-fixup tree x y-parent)))
  287.     y))
  288.  
  289. ;;; This routine makes the red-black tree a legal red-black tree again.  At
  290. ;;; entry, X is a node that is "doubly black."  X-PARENT is passed in case X
  291. ;;; is actually null.
  292. (define (rb-delete-fixup tree x x-parent)
  293.   (do ((w 'uninitialized))
  294.       ;; done when x is root or no longer black
  295.       ((or (eq? x (rb-tree-root tree))
  296.        (not (or (not x)        ;x is black if x is null
  297.             (eq? (rb-node-color x) 'black)))))
  298.     (if (eq? x (rb-node-left x-parent))
  299.     ;; note that w cannot be NIL, by red-black tree invariants, because
  300.     ;; x is doubly black, and otherwise the black-counts on the branches
  301.     ;; would be different.
  302.     (begin (set! w (rb-node-right x-parent))
  303.            ;; if w is red make it black and rotate
  304.            (cond ((eq? (rb-node-color w) 'red)
  305.               (set-rb-node-color! w 'black)
  306.               (set-rb-node-color! x-parent 'red)
  307.               (rb-left-rotate tree x-parent)
  308.               ;; this new w can't be NIL either, by same argument
  309.               (set! w (rb-node-right x-parent))))
  310.            ;; if both of w's children are black
  311.            (if (and (or (not (rb-node-left w))
  312.                 (eq? (rb-node-color (rb-node-left w)) 'black))
  313.             (or (not (rb-node-right w))
  314.                 (eq? (rb-node-color (rb-node-right w)) 'black)))
  315.            (begin (set-rb-node-color! w 'red) ;make w red
  316.               (set! x x-parent) ;move up tree
  317.               (set! x-parent (rb-node-parent x)))
  318.            (begin
  319.              (cond ((or (not (rb-node-right w))
  320.                 (eq? (rb-node-color (rb-node-right w)) 'black))
  321.                 ;; know left isn't NIL, or IF would have succeeded
  322.                 (set-rb-node-color! (rb-node-left w) 'black)
  323.                 (set-rb-node-color! w 'red)
  324.                 (rb-right-rotate tree w)
  325.                 (set! w (rb-node-right x-parent))))
  326.              (set-rb-node-color! w (rb-node-color x-parent))
  327.              (set-rb-node-color! x-parent 'black)
  328.              (if (rb-node-right w)
  329.              (set-rb-node-color! (rb-node-right w) 'black))
  330.              (rb-left-rotate tree x-parent)
  331.              (set! x (rb-tree-root tree)))))
  332.     ;; W can't be NIL here either, as above
  333.     (begin (set! w (rb-node-left x-parent))
  334.            ;; if w is red make it black and rotate
  335.            (cond ((eq? (rb-node-color w) 'red)
  336.               (set-rb-node-color! w 'black)
  337.               (set-rb-node-color! x-parent 'red)
  338.               (rb-right-rotate tree x-parent)
  339.               ;; **are we still okay in referencing x-parent here?
  340.               (set! w (rb-node-left x-parent))))
  341.            ;; if both of w's children are black
  342.            (if (and (or (not (rb-node-right w))
  343.                 (eq? (rb-node-color (rb-node-right w)) 'black))
  344.             (or (not (rb-node-left w))
  345.                 (eq? (rb-node-color (rb-node-left w)) 'black)))
  346.            (begin (set-rb-node-color! w 'red) ;make w red
  347.               (set! x x-parent) ;move up tree
  348.               (set! x-parent (rb-node-parent x)))
  349.            (begin
  350.              (cond ((or (not (rb-node-left w))
  351.                 (eq? (rb-node-color (rb-node-left w)) 'black))
  352.                 ;; know right isn't NIL, or IF would have succeeded
  353.                 (set-rb-node-color! (rb-node-right w) 'black)
  354.                 (set-rb-node-color! w 'red)
  355.                 (rb-left-rotate tree w)
  356.                 (set! w (rb-node-left x-parent))))
  357.              (set-rb-node-color! w (rb-node-color x-parent))
  358.              (set-rb-node-color! x-parent 'black)
  359.              (if (rb-node-left w)
  360.              (set-rb-node-color! (rb-node-left w) 'black))
  361.              (rb-right-rotate tree x-parent)
  362.              (set! x (rb-tree-root tree)))))))
  363.   (if x (set-rb-node-color! x 'black)))
  364.